home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Almathera Ten Pack 3: CDPD 3
/
Almathera Ten on Ten - Disc 3: CDPD3.iso
/
scope
/
026-050
/
scopedisk28
/
pipeworx
/
pipeworks
< prev
next >
Wrap
Text File
|
1995-03-18
|
10KB
|
397 lines
REM **** By Steve Sibley
REM **** this program incorporates Carolyn Scheppner's program, ~ LOAD ACBM ~
SCREEN 2,320,200,5,1:WINDOW 2,"",,16,2
ON BREAK GOSUB dun2: BREAK ON
PALETTE 0,0,0,.2:PALETTE 1,0,0,.2:PALETTE 2,0,.6,.6:PALETTE 3,0,.6,.6
CLS:COLOR 3,1:WIDTH 39
CLEAR:DEFINT a-Z
DIM TIM(255),N#(60),TIM1(255)
L#=LOG(27.5#)/LOG(2#)
FOR x=0 TO 60:N#(x) = 2^(L# + x/12):NEXT x
FOR I=0 TO 127 STEP 2:TIM(C)=I:C=C+1:NEXT I:C=100
FOR I=126 TO -127 STEP-2:TIM(C)=I:C=C+1:NEXT I:C=0
FOR I=0 TO 127 STEP 2:TIM1(C)=I:C=C+3:NEXT I:C=17
FOR I=126 TO -127 STEP-2:TIM1(C)=I:C=C+1:NEXT I
WAVE 0,TIM:WAVE 1,TIM1
ERASE TIM1:ERASE TIM
PRINT " PIPEWORKS - By Steve Sibley"
PRINT " Ever wonder how JUMPDISK gets put"
PRINT " together? It's quite simple."
PRINT " A blank formatted disk is put"
PRINT " into a network of data-filled"
PRINT " brass pipes. As the disk moves"
PRINT " through these pipes, it consumes "
PRINT " tracks of data. When the disk has"
PRINT " completed its journey, a new issue"
PRINT " of JUMPDISK is ready to go."
PRINT " To illustrate this amazing process,"
PRINT " a replica of the system follows."
PRINT " By using the arrow keys, you can"
PRINT " move the disk through the Pipeworks"
PRINT " and see for yourself how it's done."
PRINT " A point is added in the upper left"
PRINT " corner at each intersection. Score"
PRINT " of less than 65 is possible."
PRINT " Remember: It CAN by solved!"
PRINT " Patience please, while the plumber"
PRINT " stops a small data leak."
LOCATE 12,1:D!=3.6
1 CT=0:SOUND WAIT
LOOP:
READ a,B,C,D
IF a=60 AND FIN=1 THEN GOTO LOOP
IF a=1 AND FIN=1 THEN GOTO dun
IF D=11 AND T=4 THEN D!=42:a=23=B=11:C=23
IF a=60 AND FIN=0 THEN
SOUND RESUME
T=T+1
IF T=1 OR T=3 OR T=4 THEN RESTORE SONG
GOTO 1
END IF
IF a=0 OR a=60 THEN V1=0 ELSE V1=200
IF B=0 OR B=60 THEN V2=0 ELSE V2=200
IF C=0 OR C=60 THEN V3=0 ELSE V3=250
IF D=0 OR D=60 THEN V4=0 ELSE V4=140
a=N#(a):B=N#(B):C=N#(C):D=N#(D)
PL:
SOUND a,D!,V1,0:SOUND B,D!,V2,1:SOUND C,D!,V3,2:SOUND D,D!,V4,3:CT=CT+1
IF D!=42 THEN SOUND RESUME:GOSUB CLICK:CLS:GOTO Main
IF CT=4 THEN SOUND RESUME:CT=0:SOUND WAIT
GOTO LOOP
CLICK:
SOUND 110,3,180,0:SOUND 55,2,180,3
LINE(220,173)-(307,199),2,bf
COLOR 1,2:LOCATE 23,29:PRINT"CLICK HERE";
LOCATE 24,29:PRINT"TO START";
60 M=MOUSE(0):IF M=0 OR M=-1 OR M=-2 OR M=3 THEN GOTO 60
M1=MOUSE(1):M2=MOUSE(2):IF POINT(M1,M2)=1 OR POINT(M1,M2)=2 THEN COLOR 3,1:RETURN
GOTO 60
SONG:
DATA 0,24,0,16,32,27,32,20,37,41,37,25,30,34,30,18
DATA 37,41,37,13,37,41,37,25,0,28,0,24,0,27,0,23
DATA 35,39,35,23,37,41,37,25,31,35,31,19,31,35,31,19
DATA 31,35,31,19,31,19,31,24,31,35,31,19,30,34,30,18
DATA 37,41,37,13,37,41,37,25,0,28,0,24,0,27,0,23
DATA 42,46,42,18,40,44,40,28,37,41,37,25,35,30,35,23
DATA 33,37,33,21,30,34,30,18,35,39,35,27,35,27,35,23
DATA 35,39,35,27,35,27,35,23,35,39,35,27,35,27,35,11
DATA 60,60,60,60
BRIDGE:
DATA 0,24,0,16,32,20,32,20,37,41,37,25,30,34,30,18
DATA 42,46,42,30,42,46,42,25,42,37,42,30,43,47,43,31
DATA 43,37,43,31,43,47,43,35,43,55,43,31,43,50,43,37
DATA 40,52,40,28,40,44,40,33,45,49,45,37,45,45,45,33
DATA 45,49,45,33,45,57,45,21,45,52,45,25,45,49,45,33
DATA 42,46,42,30,42,46,42,25,42,37,42,30,43,47,43,31
DATA 43,37,43,31,43,47,43,35,43,55,43,31,43,50,43,37
DATA 35,39,35,23,38,42,38,26,31,35,31,19,36,40,36,24
DATA 60,60,60,60
TAG:
DATA 35,39,35,23,38,42,38,26,31,35,31,19,36,40,36,24
DATA 35,39,35,23,38,42,38,26,31,35,31,19,36,40,36,24
DATA 35,39,35,23,38,42,38,26,31,35,31,19,30,34,30,18
DATA 1,1,1,1
REM - by Carolyn Scheppner CBM 04/86
Main:
LOCATE 8,9:PRINT"Finishing repair work...
DIM bPlane&(5), cTabWork%(32), cTabSave%(32)
DECLARE FUNCTION xOpen& LIBRARY
DECLARE FUNCTION xRead& LIBRARY
DECLARE FUNCTION xWrite& LIBRARY
DECLARE FUNCTION AllocMem&() LIBRARY
LIBRARY "dos.library"
LIBRARY "exec.library"
LIBRARY "graphics.library"
ACBMname$="maze"
loadError$ = ""
GOSUB LoadACBM
OPEN "d.bob" FOR INPUT AS 1:OBJECT.SHAPE 1,INPUT$(LOF(1),1):CLOSE 1
OBJECT.X 1,14
OBJECT.Y 1,20
OBJECT.ON 1:L1=14:L2=20:COLOR 8,0
PLAY:
a$=INKEY$
IF a$=CHR$(28) THEN D=1
IF a$=CHR$(29) THEN D=2
IF a$=CHR$(30) THEN D=3
IF a$=CHR$(31) THEN D=4
IF D=0 THEN GOTO PLAY
IF D=1 THEN
IF POINT(L1,L2-1)=4 THEN L2=L2-1
IF POINT(L1,L2-1)=6 THEN L2=L2-1:D=0
IF POINT(L1,L2-1)=7 THEN GOTO BEHIND
ELSEIF D=2 THEN
IF POINT(L1,L2+3)=4 THEN L2=L2+1
IF POINT(L1,L2+3)=6 THEN L2=L2+3:D=0
IF POINT(L1,L2+3)=7 THEN GOTO BEHIND
IF POINT(L1,L2+3)=8 THEN GOTO fini
ELSEIF D=3 THEN
IF POINT(L1+3,L2)=5 THEN L1=L1+1
IF POINT(L1+3,L2)=6 THEN L1=L1+3:D=0
IF POINT(L1+3,L2)=7 THEN GOTO BEHIND
ELSEIF D=4 THEN
IF POINT(L1-1,L2)=5 THEN L1=L1-1
IF POINT(L1-1,L2)=6 THEN L1=L1-1:D=0
IF POINT(L1-1,L2)=7 THEN GOTO BEHIND
END IF
MOVE:
OBJECT.X 1,L1:OBJECT.Y 1,L2
IF D=0 THEN SOUND 100,1,150,0:SOUND 200,1,150,1:SC=SC+1:LOCATE 1,1:PRINT SC;
GOTO PLAY
BEHIND:
IF D=1 THEN
L2=L2-1
10 IF POINT(L1,L2-1)<>4 THEN L2=L2-1:GOTO 10
ELSEIF D=2 THEN
L2=L2+3
20 IF POINT(L1,L2+1)<>4 THEN L2=L2+1:GOTO 20
ELSEIF D=3 THEN
L1=L1+3
30 IF POINT(L1+1,L2)<>5 THEN L1=L1+1:GOTO 30
ELSEIF D=4 THEN
L1=L1-1
40 IF POINT(L1-1,L2)<>5 THEN L1=L1-1:GOTO 40
END IF
GOTO MOVE
LoadACBM:
REM - Requires the following variables
REM - to have been initialized:
REM - ACBMname$ (ACBM filespec)
REM - init variables
f$ = ACBMname$
fHandle& = 0
mybuf& = 0
foundBMHD = 0
foundCMAP = 0
foundCAMG = 0
foundCCRT = 0
foundABIT = 0
REM - From include/libraries/dos.h
REM - MODE_NEWFILE = 1006
REM - MODE_OLDFILE = 1005
filename$ = f$ + CHR$(0)
fHandle& = xOpen&(SADD(filename$),1005)
IF fHandle& = 0 THEN
loadError$ = "Can't open/find pic file"
GOTO Lcleanup
END IF
REM - Alloc ram for work buffers
ClearPublic& = 65537&
mybufsize& = 360
mybuf& = AllocMem&(mybufsize&,ClearPublic&)
IF mybuf& = 0 THEN
loadError$ = "Can't alloc buffer"
GOTO Lcleanup
END IF
inbuf& = mybuf&
cbuf& = mybuf& + 120
ctab& = mybuf& + 240
REM - Should read FORMnnnnACBM
rLen& = xRead&(fHandle&,inbuf&,12)
tt$ = ""
FOR kk = 8 TO 11
tt% = PEEK(inbuf& + kk)
tt$ = tt$ + CHR$(tt%)
NEXT
IF tt$ <> "ACBM" THEN
loadError$ = "Not an ACBM pic file"
GOTO Lcleanup
END IF
REM - Read ACBM chunks
ChunkLoop:
REM - Get Chunk name/length
rLen& = xRead&(fHandle&,inbuf&,8)
icLen& = PEEKL(inbuf& + 4)
tt$ = ""
FOR kk = 0 TO 3
tt% = PEEK(inbuf& + kk)
tt$ = tt$ + CHR$(tt%)
NEXT
IF tt$ = "BMHD" THEN 'BitMap header
foundBMHD = 1
rLen& = xRead&(fHandle&,inbuf&,icLen&)
iWidth% = PEEKW(inbuf&)
iHeight% = PEEKW(inbuf& + 2)
iDepth% = PEEK(inbuf& + 8)
iCompr% = PEEK(inbuf& + 10)
scrWidth% = PEEKW(inbuf& + 16)
scrHeight% = PEEKW(inbuf& + 18)
iRowBytes% = iWidth% /8
scrRowBytes% = scrWidth% / 8
nColors% = 2^(iDepth%)
REM - Enough free ram to display ?
AvailRam& = FRE(-1)
NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
IF AvailRam& < NeededRam& THEN
loadError$ = "Not enough free ram."
GOTO Lcleanup
END IF
kk = 1
IF scrWidth% > 320 THEN kk = kk + 1
IF scrHeight% > 200 THEN kk = kk + 2
REM - Get addresses of structures
GOSUB GetScrAddrs
REM - Black out screen
CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
ELSEIF tt$ = "CMAP" THEN 'ColorMap
foundCMAP = 1
rLen& = xRead&(fHandle&,cbuf&,icLen&)
REM - Build Color Table
FOR kk = 0 TO nColors% - 1
red% = PEEK(cbuf&+(kk*3))
gre% = PEEK(cbuf&+(kk*3)+1)
blu% = PEEK(cbuf&+(kk*3)+2)
regTemp% = (red%*16)+(gre%)+(blu%/16)
POKEW(ctab&+(2*kk)),regTemp%
NEXT
ELSEIF tt$ = "CAMG" THEN 'Amiga ViewPort Modes
foundCAMG = 1
rLen& = xRead&(fHandle&,inbuf&,icLen&)
camgModes& = PEEKL(inbuf&)
ELSEIF tt$ = "ABIT" THEN 'Contiguous BitMap
foundABIT = 1
REM - This only handles full size BitMaps, not brushes
REM - Very fast - reads in entire BitPlanes
plSize& = (scrWidth%/8) * scrHeight%
FOR pp = 0 TO iDepth% -1
rLen& = xRead&(fHandle&,bPlane&(pp),plSize&)
NEXT
ELSE
REM - Reading unknown chunk
FOR kk = 1 TO icLen&
rLen& = xRead&(fHandle&,inbuf&,1)
NEXT
REM - If odd length, read 1 more byte
IF (icLen& OR 1) = icLen& THEN
rLen& = xRead&(fHandle&,inbuf&,1)
END IF
END IF
PALETTE 1,0,0,0
REM - Done if got all chunks
IF foundBMHD AND foundCMAP AND foundABIT THEN
GOTO GoodLoad
END IF
REM - Good read, get next chunk
IF rLen& > 0 THEN GOTO ChunkLoop
IF rLen& < 0 THEN 'Read error
loadError$ = "Read error"
GOTO Lcleanup
END IF
REM - rLen& = 0 means EOF
IF (foundBMHD=0) OR (foundABIT=0) OR (foundCMAP=0) THEN
loadError$ = "Needed ILBM chunks not found"
GOTO Lcleanup
END IF
GoodLoad:
loadError$ =""
REM Load proper Colors
IF foundCMAP THEN
CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
PALETTE 1,.23,0,0
END IF
Lcleanup:
IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
PALETTE 30,1,.9,.7:PALETTE 31,.3,.1,0
RETURN
GetScrAddrs:
REM - Get addresses of screen structures
sWindow& = WINDOW(7)
sScreen& = PEEKL(sWindow& + 46)
sViewPort& = sScreen& + 44
sRastPort& = sScreen& + 84
sColorMap& = PEEKL(sViewPort& + 4)
colorTab& = PEEKL(sColorMap& + 4)
sBitMap& = PEEKL(sRastPort& + 4)
REM - Get screen parameters
scrWidth% = PEEKW(sScreen& + 12)
scrHeight% = PEEKW(sScreen& + 14)
scrDepth% = PEEK(sBitMap& + 5)
nColors% = 2^scrDepth%
REM - Get addresses of Bit Planes
FOR kk = 0 TO scrDepth% - 1
bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
NEXT
RETURN
fini:
OBJECT.OFF 1
PALETTE 16,.2,0,.3
LINE(105,9)-(2,28),16,bf
LINE(2,187)-(320,28),16,bf
LINE(194,9)-(320,28),16,bf
LINE(20,28)-(290,130),8,bf
COLOR 3,8
LOCATE 5,5:PRINT" DISK MAGAZINE FOR THE AMIGA "
CIRCLE(270,32),4,3:LINE(270,31)-(270,33),3:LINE(269,31)-(271,31),3
LOCATE 8,9:PRINT "CONGRATULATIONS"
LOCATE 10,9:PRINT"ON FINDING YOUR WAY"
LOCATE 11,9:PRINT"THROUGH THE PIPEWORKS."
LOCATE 13,9:PRINT"You are a truly"
LOCATE 14,9:PRINT"persistent person."
FIN=1:D!=3.6:GOTO 1
dun2:
COLOR 8,16:LOCATE 20,8:PRINT" Perhaps next time. "
dun:
LOCATE 21,8:PRINT " Press any key to exit. "
100 a$=INKEY$:IF a$="" THEN GOTO 100
WINDOW CLOSE 2
SCREEN CLOSE 2
SYSTEM